home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / Mops 2.7 / Mops source / System source / String+ < prev    next >
Text File  |  1995-07-19  |  14KB  |  601 lines
  1. \ STRING+ class.  This adds many useful methods to class String.
  2.  
  3. :class    STRING+  super{ string }
  4.  
  5.  
  6. \        ======  Utility methods  ======
  7.  
  8.  
  9. :m SWAPPOS:    \ Swaps POS with the top of the stack.
  10.     get: pos  swap  put: pos   ;m
  11.  
  12. :m SAVE:        \ ( -- hnd pos lim )  Saves the string+ object on the stack.
  13.     handle: self  pos: self  lim: self   ;m
  14.  
  15. :m RESTORE:    \ ( hnd pos lim -- )  Just what you'd expect.
  16.     >lim: self  >pos: self  ^base !   ;m
  17.  
  18.  
  19. :mcode 2ND:    \ ( -- c )
  20.         loc        \ Returns the 2nd char in the active part, or 0 if none.
  21.         MOVEQ    #0,D1
  22.         BSR        dic[getit]
  23.         BNE.S    ok
  24.         JMP        dic[$fail]
  25. ok        SUBQ    #1,D0
  26.         BLE.S    end
  27.         MOVE.B    1(A0),D1
  28. end        MOVE    D1,-(SP)
  29. ;mcode
  30.  
  31. :mcode LAST:    \ ( -- c )
  32.         loc        \ Returns the last char in the active part.
  33.         MOVEQ    #0,D1
  34.         BSR        dic[getit]
  35.         BNE.S    ok
  36.         JMP        dic[$fail]
  37. ok        MOVE    dic[$start],A1    ; A1 -> start of string
  38.         ADD        12(A2),A1    ; Add LIM, giving end of active part
  39.         MOVE.B    -1(A1),D1    ; Pick up last char
  40.         MOVE    D1,-(SP)
  41. ;mcode
  42.  
  43.  
  44. \            ===========  Comparison:  ===========
  45.  
  46. :m  COMPARE:    \ ( addr len -- n )   Compares the string ( addr len )
  47.         \ with the active part of SELF.  Comparison is
  48.         \ by CMPSTR, with the ( addr len ) string as the first
  49.         \ operand.  n is the return result as described above
  50.         \ for CMPSTR.
  51.     get: self  cmpstr   ;m
  52.  
  53.  
  54. :m  ?:  { addr len -- n }
  55.         \ As for COMPARE:, except that if the ( addr len ) string
  56.         \ is shorter than the active part of SELF, only len chars
  57.         \ from the current position of SELF are used.  This only
  58.         \ makes a difference if an "equal" result is obtained.
  59.     addr len  get: self  len min  cmpstr   ;m
  60.  
  61.  
  62. :m  =?:  { addr len -- f }
  63.         \ A compare for equal/not equal only.
  64.         \ Returns true on equal.
  65.     addr len  get: self  len min  cmpstr 0=   ;m
  66.  
  67.  
  68. :mcode CH=?:    \ ( c -- f )
  69.         \ Compares the given single character against the 
  70.         \ character at POS.  Returns true on equal.
  71.         \ If the active part of the string is empty,
  72.         \ always returns false.
  73.         loc
  74.         MOVE    (SP),D1
  75.         CLR        (SP)
  76.         BSR        dic[getit]
  77.         BEQ.S    end
  78.         TST        dic[case?]
  79.         BEQ.S    nocase
  80.         CMP.B    (A0),D1
  81.         BNE.S    end
  82.         BRA.S    yes
  83.  
  84. nocase    LEA        8(dic[UCtbl]),A1
  85.         MOVE.B    0(A1,D1.W),D0
  86.         MOVE.B    (A0),D1
  87.         CMP.B    0(A1,D1.W),D0
  88.         BNE.S    end
  89. yes        MOVE    #-1,(SP)
  90. end
  91. ;mcode
  92.  
  93.  
  94. \            ============= Searching ==============
  95.  
  96. \ SEARCH: and <SEARCH: search for the passed-in string.  They return a boolean
  97. \ indicating if found.
  98.  
  99. :mcode SEARCH:    \ ( addr len -- b )
  100.         loc
  101.         BSR        dic[getit]
  102.         MOVE    D4,-(A7)    ; Save D4 on return stk
  103.         POP        D4            ; D4 = len
  104.         MOVE    (SP),A1        ; A1 = addr - search string
  105.         CLR        (SP)        ; For return result
  106.         MOVEQ    #0,D1
  107.         MOVE.B    (A1)+,D1    ; D1 = 1st char of search string
  108.         SUBQ    #1,D4        ; D4 = length of rest of sch str
  109.         SUB        D4,D0
  110.         BLE.S    end            ; Out with False if self not long 
  111.                             ;  enough
  112.  
  113. loop    BSR    dic[csch]
  114.         BNE.S    end
  115.         MOVEM    D0/D1/A0/A1,-(SP)    ; Save regs across ccmp call
  116.         MOVE    D4,D0
  117.         BSR        dic[ccmp]
  118.         MOVEM    (SP)+,D0/D1/A0/A1
  119.         BNE.S    loop
  120.  
  121.         SUBQ    #1,(SP)        ; Found
  122.         SUBQ    #1,A0
  123.         SUB        dic[$start],A0
  124.         MOVE    A0,12(A2)    ; Set LIM to found position
  125. end        MOVE    (A7)+,D4    ; Restore D4
  126. ;mcode
  127.  
  128.  
  129. :mcode <SEARCH:    \ ( addr len -- b )
  130.         loc
  131.         BSR    dic[getit]
  132.         MOVE    D4,-(A7)    ; Save D4 on return stk
  133.         POP        D4            ; D4 = len
  134.         MOVE    (SP),A1        ; A1 = addr
  135.         CLR        (SP)        ; For return result
  136.         MOVEQ    #0,D1
  137.         MOVE.B    (A1)+,D1    ; D1 = 1st char of search string
  138.         SUBQ    #1,D4        ; D4 = length of rest of sch str
  139.         SUB        D4,D0        ; Reduce search length by this amount
  140.         BLE.S    end            ; Out with False if self not long enough
  141.         MOVE    D0,D2        ; OK, but need to adjust D2 as well
  142.         SWAP    D2
  143.         ADD        D0,A0
  144.  
  145. loop    BSR        dic[<csch]
  146.         BNE.S    end
  147.         MOVEM    D0/D1/A0/A1,-(SP)    ; Save regs across ccmp call
  148.         MOVE    D4,D0
  149.         ADDQ    #1,A0
  150.         BSR        dic[ccmp]
  151.         MOVEM    (SP)+,D0/D1/A0/A1
  152.         BNE.S    loop
  153.  
  154.         SUBQ    #1,(SP)    ; Found
  155.         SUB        dic[$start],A0
  156.         MOVE    A0,8(A2)
  157. end        MOVE    (A7)+,D4    ; Restore D4
  158. ;mcode
  159.  
  160.  
  161. :m  SCH&SKIP:  { addr len \ savelim -- b }
  162.         \ Searches for the string ( addr len )
  163.         \ and if found, sets POS to the character following the
  164.         \ found substring.  Leaves LIM unchanged.
  165.  
  166.     get: lim  -> savelim
  167.     addr len  search: self  dup  0EXIT
  168.     step: self  len  skip: self  savelim  put: lim  ;m
  169.  
  170.  
  171. \ CHSEARCH: and <CHSEARCH: search for a single character.
  172.  
  173. :mcode CHSEARCH:    \ ( c -- b )
  174.         loc
  175.         MOVE    (SP),D1        ; D1 = char
  176.         CLR        (SP)        ; for return result
  177.         BSR        dic[getit]
  178.         BLE.S    end
  179.         BSR        dic[csch]
  180.         BNE.S    end
  181.         SUBQ    #1,(SP)        ; Set result to "true"
  182.         SUBQ    #1,A0
  183.         SUB        dic[$start],A0
  184.         MOVE    A0,12(A2)
  185. end
  186. ;mcode
  187.  
  188. :mcode <CHSEARCH:    \ ( c -- b )
  189.         loc
  190.         MOVE    (SP),D1
  191.         CLR        (SP)
  192.         BSR        dic[getit]
  193.         BLE.S    end
  194.         ADD        D0,A0
  195.         BSR        dic[<csch]
  196.         BNE.S    end
  197.         SUBQ    #1,(SP)
  198.         SUB        dic[$start],A0
  199.         MOVE    A0,8(A2)
  200. end
  201. ;mcode
  202.  
  203.  
  204. :m CHSCH&SKIP:  { c \ savelim -- b }
  205.     get: lim  -> savelim
  206.     c  chsearch: self  dup  0EXIT
  207.     step: self  1 skip: self  savelim  put: lim   ;m
  208.  
  209.  
  210. \ CHSKIP?:  ( c -- b )  searches for the first character NOT equal to c.
  211. \ This method has a couple of differences to the other searching methods, 
  212. \ dictated by what we normally need it for.  If it suceeds, POS (not LIM) is 
  213. \ set to that position, and it is always case sensitive, regardless of CASE?.
  214.  
  215. :mcode CHSKIP?:
  216.         loc
  217.         MOVE    (SP),D1        ; D1 = char
  218.         CLR        (SP)
  219.         BSR        dic[getit]
  220.         BLE.S    end
  221.         CMP.B    D0,D0        ; Set "equal"
  222.         BRA.S    lptst
  223.  
  224. loop    CMP.B    (A0)+,D1
  225. lptst    DBNE    D0,loop
  226.         DBNE    D2,loop
  227.         BEQ.S    end
  228.         SUBQ    #1,A0
  229.         SUB        dic[$start],A0
  230.         MOVE    A0,8(A2)
  231.         SUBQ    #1,(SP)
  232. end
  233. ;mcode
  234.  
  235. :m  CHSKIP:        \ ( c -- )  As for CHSKIP?:, but returns no result.
  236.     chskip?: self  drop   ;m
  237.  
  238.  
  239. \ SCAN: and <SCAN: search for a single character, using a translate table.
  240. \ "Success" is defined as a character which yields a non-zero value from
  241. \ the table.  The return result is this non-zero value, or zero if none
  242. \ was found.
  243.  
  244. :mcode SCAN:        \ ( trtbl -- n )
  245.         loc
  246. scan    MOVEQ    #0,D1        ; For result
  247.         BSR        dic[getit]
  248.         BLE.S    end
  249.         MOVE    (SP),A1
  250.         TST.B    scaxq
  251.         BEQ.S    lptst        ; Note: for both SCAN: and SCAX: we enter
  252.         BRA.S    lptstx        ; the loop with the CC not satisfying the
  253.                             ; test condition.  Important!!
  254.  
  255. scaxq    dc.w    0            ; Set nonzero if this is a scax
  256.  
  257. loop    MOVE.B    (A0)+,D1
  258.         MOVE.B    2(A1,D1.W),D1
  259. lptst    DBNE    D0,loop
  260.         DBNE    D2,loop
  261.         BEQ.S    end            ; If not found
  262.         BRA.S    found
  263.  
  264. loopx    MOVE.B    (A0)+,D1
  265.         MOVE.B    2(A1,D1.W),D1
  266. lptstx    DBEQ    D0,loopx
  267.         DBEQ    D2,loopx
  268.         BNE.S    end            ; If not found
  269.  
  270. found    SUBQ    #1,A0
  271.         SUB        dic[$start],A0
  272.         MOVE    A0,12(A2)
  273. end        MOVE    D1,(SP)
  274.         CLR.B    scaxq
  275. ;mcode
  276.  
  277. :mcode <SCAN:    \ ( trtbl -- n )
  278.  
  279. bscan    MOVEQ    #0,D1    ; For result
  280.         BSR        dic[getit]
  281.         BLE.S    bend
  282.         MOVE    (SP),A1
  283.         ADD        D0,A0
  284.         TST.B    scaxq
  285.         BEQ.S    blptst
  286.         BRA.S    blptstx
  287.  
  288. bloop    MOVE.B    -(A0),D1
  289.         MOVE.B    2(A1,D1.W),D1
  290. blptst    DBNE    D0,bloop
  291.         DBNE    D2,bloop
  292.         BRA.S    bfix
  293.  
  294. bloopx    MOVE.B    -(A0),D1
  295.         MOVE.B    2(A1,D1.W),D1
  296. blptstx    DBEQ    D0,bloopx
  297.         DBEQ    D2,bloopx
  298.  
  299. bfix    SUB        dic[$start],A0
  300.         MOVE    A0,8(A2)
  301. bend    MOVE    D1,(SP)
  302.         CLR.B    scaxq
  303. ;mcode
  304.  
  305.  
  306. \ SCAX: and <SCAX: - "Scan excluding".  As for scan:, but "success" is
  307. \ defined as a character which yields a zero value from the table.
  308. \ The return result is the last byte fetched from the table, which
  309. \ will be zero on success, or otherwise it will be whatever table byte
  310. \ corresponds to the last char in the active part of the string - 
  311. \ something non-zero, in any case.
  312.  
  313. :mcode  SCAX:
  314.         SUBQ.B    #1,scaxq
  315.         BRA        scan
  316. ;mcode
  317.  
  318. :mcode  <SCAX:
  319.         SUBQ.B    #1,scaxq
  320.         BRA        bscan
  321. ;mcode
  322.  
  323.  
  324. :mcode TRANSLATE:    \ ( trtbl -- )
  325.         loc
  326.         POP    A1
  327.         BSR        dic[getit]
  328.         BLE.S    end
  329.         MOVEQ    #0,D1
  330.         BRA.S    lptst
  331.  
  332. loop    MOVE.B    (A0),D1
  333.         MOVE.B    2(A1,D1.W),(A0)+
  334. lptst    DBRA    D0,loop
  335.         DBRA    D2,loop
  336. end
  337. ;mcode
  338.  
  339.  
  340. :mcode TRANS1ST:    \ ( trtbl -- n )
  341.         loc
  342.         MOVEQ    #0,D1
  343.         BSR        dic[getit]
  344.         BLE.S    end
  345.         MOVE    (SP),A1
  346.         MOVE.B    (A0),D1
  347.         MOVE.B    2(A1,D1.W),D1
  348. end        MOVE    D1,(SP)
  349. ;mcode
  350.  
  351.  
  352. :m  >UC:        \ Faster than UPPER, and not limited to 64K.
  353.     UCtbl  translate: self   ;m
  354.  
  355. :m  CH>UC:    \ Converts the first char of SELF to upper case.
  356.     UCtbl  trans1st: self   ^1st: self  c!   ;m
  357.  
  358.  
  359. \    ========= Insertion, deletion, replacement ==========
  360.  
  361.  
  362. :m  CHINSERT:    \ ( c -- )  Inserts the given character.
  363.     pad c!  pad 1 insert: super   ;m
  364.  
  365.  
  366. :m  OVWR:  { addr len -- }
  367.  
  368. \ Overwrites the active part of SELF with the string ( addr len ).
  369. \ Copying stops at the end of the active part, or when len characters
  370. \ have been transferred.  POS is incremented by the number of chars
  371. \ transferred.  This operation is faster than normal replacement, as the
  372. \ length of SELF cannot change, so Munger is not called.
  373.  
  374.     addr  get: self  len min  dup -> len  cmove
  375.     len +: pos   ;m
  376.  
  377. :m  CHOVWR:    \ ( c -- )  Overwrites the first char of the active
  378.         \ part of the string ( if any ) by the char c.
  379.     get: self  IF  c!  1 skip: self  else  2drop  THEN   ;m
  380.  
  381.  
  382. :m  $OVWR:    \ ( str -- )
  383.     get: string+  ovwr: self    ;m
  384.  
  385.  
  386. private
  387. :m  (REPL):  { len1 addr2 len2 -- }
  388.     0 len1  addr2 len2  munger: self  put: pos  ;m
  389.  
  390. public
  391.  
  392. :m REPL:  { addr len -- }
  393.     len: self  addr len  (repl): self
  394.     get: pos  put: lim  ;m
  395.  
  396. :m $REPL:  { str \ state -- }
  397.     str getState: string  -> state  str lock: string
  398.     str get: string  repl: self
  399.     state  str setState: string  ;m
  400.  
  401.  
  402. :m SCH&REPL:  { addr1 len1 addr2 len2 -- b }
  403.     addr1 len1  search: self  dup  0EXIT
  404.     step: self
  405.     len1  addr2 len2  (repl): self
  406.     get: pos  put: lim  ;m
  407.  
  408.  
  409. :m REPLALL:  { addr1 len1 addr2 len2 -- }
  410.         \ Replaces all occurrences of (addr1 len1) by (addr2 len2)
  411.         \ in the WHOLE of self.  Self is left reset.
  412.     reset: self
  413.     BEGIN    addr1 len1  search: self
  414.     WHILE    step: self
  415.         len1 addr2 len2  (repl): self  nolim: self
  416.     REPEAT
  417.     clear: pos  ;m
  418.  
  419.  
  420. :m DELETE:    \ Deletes the active part of the string.
  421.         \ LIM is then set equal to POS.
  422.     0 0  repl: self  ;m
  423.  
  424.  
  425. :m DELETEN:  { n -- }
  426.         \ From POS, deletes n characters or up to LIM,
  427.         \ whichever comes first.  LIM is reduced by the number
  428.         \ of characters deleted.
  429.     len: self  n  min  dup -> n
  430.     0 0  (repl): self
  431.     n negate  +: lim  ;m
  432.  
  433.  
  434. \        ========= Line-oriented methods: =========
  435.  
  436. \ LINE>: sets LIM to the end of the current line (i.e. the next Return
  437. \ character, or the end of the string).  POS isn't moved -- it need not
  438. \ be at the start of the line.
  439.  
  440. :mcode LINE>:
  441.         loc
  442.         MOVE    4(A2),12(A2)        ; nolim: self
  443.         BSR        dic[getit]
  444.         BLE.S    end
  445.         SUBQ    #1,D0
  446. loop    CMPI.B    #13,(A0)+
  447.         DBEQ    D0,loop
  448.         BNE.S    end
  449.         SUBQ    #1,A0
  450.         SUB        dic[$start],A0
  451.         MOVE    A0,12(A2)
  452. end
  453. ;mcode
  454.  
  455.  
  456. \ NEXTLINE?: sets POS and LIM to delimit the next line.  This means POS
  457. \ will point to the Return character, and LIM to the char preceding the
  458. \ next Return, or the end of the string.  If LIM initially does not point
  459. \ to a Return character, the "next" line will actually be the rest of the
  460. \ current one, starting from where LIM pointed.  This behaviour means that
  461. \ if POS and LIM are initially zero, calling NEXTLINE?: will actually
  462. \ yield the first line.   This can be useful.
  463.  
  464. :mcode NEXTLINE?:   \ ( -- f )
  465.         loc
  466.         CLR        -(SP)
  467.         MOVE    (A2),A0
  468.         MOVE    (A0),A0
  469.         MOVE    4(A2),D0
  470.         MOVE    12(A2),D1
  471.         MOVE    D1,8(A2)
  472.         MOVE    D0,12(A2)
  473.         SUB        D1,D0
  474.         BLE.S    end
  475.         SUBQ    #1,(SP)            ; We'll get some kind of line! 
  476.         MOVE    A0,A1
  477.         ADD        D1,A0
  478.         CMPI.B    #13,(A0)+
  479.         BNE.S    ready
  480.         ADDQ    #1,8(A2)
  481. ready    SUBQ    #1,D0
  482.         BEQ.S    setlim
  483.         SUBQ    #1,D0
  484.         move    d0,d2
  485.         swap    d2
  486. loop    CMPI.B    #13,(A0)+
  487.         DBEQ    D0,loop
  488.         dbeq    d2,loop
  489.         BNE.S    setlim
  490.         SUBQ    #1,A0
  491. setlim    SUB        A1,A0
  492.         MOVE    A0,12(A2)
  493. end
  494. ;mcode
  495.  
  496.  
  497. \ The reverse operation is a bit easier because we don't need to check
  498. \ if POS is initially pointing at a Return.
  499.  
  500. :m <NEXTLINE?:
  501.     <step: self
  502.     len: self  NIF  false  EXIT  THEN
  503.     RET  <chsearch: self  drop  true  ;m
  504.  
  505.  
  506. :m ADDLINE:        \ ( addr len -- )
  507.     add: self
  508.     get: size
  509.     if    ^1st: self 1- c@  RET =   else    false    then    ?exit
  510.     RET  +: self  ;m
  511.  
  512. :m $ADDLINE:  { str \ state -- }
  513.     str getState: string  -> state  str lock: string
  514.     str get: string  addline: self
  515.     state  str setState: string  ;m
  516.     
  517.  
  518. \        =========== I/O operations: ============
  519.  
  520. :m READN:  { fcb n \ state -- }
  521.         \ Reads n bytes from the given file
  522.         \ into SELF, completely replacing whatever was there before.
  523.         \ The read stops when end file is reached.
  524.     n setsize: self
  525.     getState: self  -> state  lock: self
  526.     all: self  fcb read: file
  527.     state  setState: self
  528.     dup -39 =  IF  drop  0  THEN  OK?        \ We don't worry if the error
  529.                                             \  was endfile
  530.     bytesRead: [ fcb ]  setSize: self  ;m
  531.  
  532.  
  533. :m READLINE?:  { fcb n \ state -- b }
  534.         \ Reads the next line up to a max of n chars.
  535.         \ Returns false if end of file.  Does not
  536.         \ include the final Return char.
  537.     n setsize: self
  538.     getState: self  -> state  lock: self
  539.     all: self  fcb readline: file
  540.     state  setState: self
  541.     dup
  542.     NIF                \ Success.  Assume we got a Return
  543.         drop  fcb bytesRead: file 1-  setSize: self
  544.         true  exit
  545.     THEN
  546.     dup EOF =
  547.     IF                \ Return True if we got any bytes at all
  548.         drop  fcb bytesRead: file  dup  setSize: self  0<>  exit
  549.     THEN
  550.     ( File error - cause error handler to execute )  OK?  ;m
  551.  
  552.  
  553. :m READREST:  { fcb -- }
  554.         \ Reads all the remainder of the given file into SELF.
  555.     fcb  fcb size: file  readn: self  ;m
  556.  
  557.  
  558. :m READALL:  { fcb -- }        \ Reads all the given file into SELF.
  559.     0  fcb moveto: file  OK?  fcb readRest: self  ;m
  560.  
  561.  
  562. :m READTOP:        \ Reads all of TOPFILE into SELF, then closes and
  563.                 \ drops TOPFILE.  TOPFILE must already be open.
  564.     topfile  readAll: self
  565.     close: topfile  OK?  drop: loadfile  ;m
  566.  
  567.  
  568. :m  $WRITE:  { fcb -- }
  569.     get: self  fcb write: file  OK?  ;m
  570.  
  571.  
  572. :m SEND:  { fcb -- }
  573.     ^base 4+  12  fcb write: file  OK?
  574.     all: self  fcb write: file  OK?  ;m
  575.  
  576.  
  577. :m BRING:  { fcb -- }
  578.     ^base 4+  12  fcb read: file  OK?
  579.     ?new: self  size: self  ^base  setsize: handle
  580.     all: self  fcb read: file  OK?  ;m
  581.  
  582.  
  583. :m DRAW:  { tRect just -- }  \ Draws the string justified in rect tRect.
  584.     get: self
  585.     tRect  just makeint  call textBox  ;m
  586.  
  587.  
  588. :m PRINTALL:   { \ svPos svLim svCurs 1st? -- }
  589.     nil?: self  IF  Nopen  EXIT  THEN
  590.     get: pos  -> svPos  get: lim  -> svLim
  591.     curs -> svCurs  -curs
  592.     begin: self  true -> 1st?
  593.     BEGIN    nextline?: self
  594.     WHILE    get: self  type
  595.         1st? if  false -> 1st?  else  cr  0 -> out  then
  596.     REPEAT
  597.     svPos  put: pos  svLim  put: lim
  598.     svCurs -> curs  ;m
  599.  
  600. ;class
  601.